home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / wc_Command.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  16.1 KB  |  431 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         wc_Command.c
  5. * RCS:          $Header: wc_Command.c,v 1.3 91/03/14 03:14:32 mayer Exp $
  6. * Description:  XM_COMMAND_WIDGET_CLASS
  7. * Author:       Niels Mayer, HPLabs
  8. * Created:      Fri Oct 27 21:57:58 1989
  9. * Modified:     Thu Oct  3 23:56:43 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: wc_Command.c,v 1.3 91/03/14 03:14:32 mayer Exp $";
  43.  
  44. #include <stdio.h>
  45. #include <Xm/Xm.h>
  46. #include <Xm/Command.h>
  47. #include "winterp.h"
  48. #include "user_prefs.h"
  49. #include "xlisp/xlisp.h"
  50. #include "w_funtab.h"
  51. #include "w_XmString.h"
  52.  
  53. extern Widget Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(); /* w_classes.c */
  54.  
  55.  
  56. /*****************************************************************************
  57.  * (send XM_COMMAND_WIDGET_CLASS :new
  58.  *                 [:managed/:unmanaged]
  59.  *                           [<name>]
  60.  *                           <parent> 
  61.  *                           [:XMN_<arg1> <val1>]
  62.  *                           [. . .             ]
  63.  *                           [:XMN_<argN> <valN>])
  64.  *
  65.  * Create a new widget via XmCreateCommand().
  66.  *
  67.  * The optional keyword-argument :managed will cause a subsequent call to
  68.  * XtManageChild(). If the submessage :unmanaged is present, or no submessage,
  69.  * then XtManageChild() won't be called, and the resulting widget will be
  70.  * returned unmanaged.
  71.  ****************************************************************************/
  72. LVAL Xm_Command_Widget_Class_Method_ISNEW()
  73. {
  74.   extern ArgList Wres_Get_LispArglist(); /* from w_resources.c */
  75.   extern void    Wres_Free_C_Arglist_Data(); /* from w_resources.c */
  76.   extern LVAL k_managed, k_unmanaged;
  77.   LVAL self, o_parent;
  78.   char* name;
  79.   Boolean managed_p;
  80.   Widget parent_widget_id, widget_id;
  81.  
  82.   self = xlgaobject();        /* NOTE: xlobj.c:clnew() returns an OBJECT; if this method
  83.                    returns successfully, it will return a WIDGETOBJ */
  84.  
  85.   /* get optional managed/unmanaged arg */
  86.   if (moreargs() && ((*xlargv == k_managed) || (*xlargv == k_unmanaged)))
  87.     managed_p = (nextarg() == k_managed);
  88.   else
  89.     managed_p = FALSE;        /* by default don't call XtManageChild() */
  90.  
  91.   /* get optional <name> arg */
  92.   if (moreargs() && (stringp(*xlargv)))
  93.     name = (char*) getstring(nextarg());
  94.   else
  95.     name = "";            /* default name */
  96.  
  97.   /* get required <parent> widget-object arg */
  98.   parent_widget_id = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&o_parent);
  99.  
  100.   /*
  101.    * Store the widget object <self> in the XmNuserData resource on the
  102.    * widget. This will allow us to retrieve the widget object from Xtoolkit
  103.    * functions returning widget ID's without having to keep around a table
  104.    * of widgetID-->widget-objects.
  105.    */
  106.    ARGLIST_RESET(); ARGLIST_ADD(XmNuserData, (XtArgVal) self); 
  107.  
  108.   if (moreargs()) {        /* if there are more arguments, */
  109.     Cardinal xt_numargs;    /* then we have some extra widget resources to set */
  110.     ArgList xt_arglist = Wres_Get_LispArglist(self, parent_widget_id, ARGLIST(), &xt_numargs);
  111.     widget_id = XmCreateCommand(parent_widget_id, name, xt_arglist, xt_numargs);
  112.     Wres_Free_C_Arglist_Data();
  113.   }
  114.   else 
  115.     widget_id = XmCreateCommand(parent_widget_id, name, ARGLIST());
  116.   
  117.   Wcls_Initialize_WIDGETOBJ(self, widget_id);
  118.  
  119.   if (managed_p)
  120.     XtManageChild(widget_id);
  121.  
  122. #ifdef DEBUG_WINTERP_1
  123.   Wcls_Print_WidgetObj_Info(self);
  124. #endif
  125.   return (self);
  126. }
  127.  
  128.  
  129. /******************************************************************************
  130.  * typedef struct
  131.  * {
  132.  *     int reason;
  133.  *     XEvent    *event;
  134.  *     XmString    value;
  135.  *     int    length;
  136.  * } XmCommandCallbackStruct;
  137.  ******************************************************************************/
  138. static void Lexical_Bindings_For_XmCommandCallbackStruct(bindings_list, lexical_env, cd, o_widget)
  139.      LVAL bindings_list;    /* a list of symbols to which values from XmCommandCallbackStruct are bound */
  140.      LVAL lexical_env;        
  141.      XmCommandCallbackStruct* cd;
  142.      LVAL o_widget;        /* XLTYPE_WIDGETOBJ */
  143. {
  144.   extern LVAL s_CALLBACK_WIDGET, s_CALLBACK_REASON, s_CALLBACK_XEVENT, s_CALLBACK_VALUE, s_CALLBACK_LENGTH; /* w_callbacks.c */
  145.   extern LVAL Wcb_Get_Callback_Reason_Symbol();    /* w_callbacks.c */
  146.   register LVAL s_bindname;
  147.  
  148.   for ( ; consp(bindings_list); bindings_list = cdr(bindings_list)) {
  149.  
  150.     s_bindname = car(bindings_list);
  151.  
  152.     if (s_bindname == s_CALLBACK_WIDGET) {
  153.       xlpbind(s_bindname, o_widget, lexical_env);
  154.     }
  155.     else if (s_bindname == s_CALLBACK_REASON) {
  156.       xlpbind(s_bindname, Wcb_Get_Callback_Reason_Symbol(cd->reason), lexical_env);
  157.     }
  158.     else if (s_bindname == s_CALLBACK_XEVENT) {
  159.       xlpbind(s_bindname, (cd->event) ? cv_xevent(cd->event) : NIL, lexical_env);
  160.     }
  161.     else if (s_bindname == s_CALLBACK_VALUE) {
  162.       xlpbind(s_bindname, (cd->value) ? cv_xmstring(XmStringCopy(cd->value)) : NIL, lexical_env);
  163.     }
  164.     else if (s_bindname == s_CALLBACK_LENGTH) {
  165.       xlpbind(s_bindname, cvfixnum((FIXTYPE) cd->length), lexical_env);
  166.     }
  167.     else {
  168.       extern char temptext[];    /* from winterp.c */
  169.       sprintf(temptext,
  170.           "Unknown binding name in XmCommandCallbackStruct callback evaluator. Valid symbols are [%s %s %s %s %s].",
  171.           (char*) getstring(getpname(s_CALLBACK_WIDGET)),
  172.           (char*) getstring(getpname(s_CALLBACK_REASON)),
  173.           (char*) getstring(getpname(s_CALLBACK_XEVENT)),
  174.           (char*) getstring(getpname(s_CALLBACK_VALUE)),
  175.           (char*) getstring(getpname(s_CALLBACK_LENGTH)));
  176.       xlerror(temptext, s_bindname);
  177.     }
  178.   }
  179. }
  180.  
  181.  
  182. /******************************************************************************
  183.  * This is called indirectly via XtAddCallback() for callbacks returning
  184.  * an XmCommandCallbackStruct as call_data.
  185.  ******************************************************************************/
  186. static void XmCommandCallbackStruct_Callbackproc(widget, client_data, call_data)
  187.      Widget    widget;
  188.      XtPointer client_data;
  189.      XtPointer call_data;
  190. {
  191.   extern void Wcb_Meta_Callbackproc(); /* w_callbacks.c */
  192.  
  193.   Wcb_Meta_Callbackproc(client_data, call_data,
  194.             Lexical_Bindings_For_XmCommandCallbackStruct,
  195.             NULL);
  196. }
  197.  
  198.  
  199. /******************************************************************************
  200.  * Same as WIDGET_CLASS's :add_callback method except that this understands
  201.  * how to get values from the XmCommandCallbackStruct.
  202.  * Specifying one or more of the following symbols in the callback bindings 
  203.  * list will bind that symbol's value in the lexical environment of the callback:
  204.  * CALLBACK_WIDGET
  205.  * CALLBACK_REASON
  206.  * CALLBACK_XEVENT
  207.  * CALLBACK_VALUE
  208.  * CALLBACK_LENGTH
  209.  ******************************************************************************/
  210. LVAL Xm_Command_Widget_Class_Method_ADD_CALLBACK()
  211. {
  212.   extern LVAL Wcb_Meta_Method_Add_Callback(); /* w_callbacks.c */
  213.  
  214.   return (Wcb_Meta_Method_Add_Callback(XmCommandCallbackStruct_Callbackproc, FALSE));
  215. }
  216.  
  217.  
  218. /******************************************************************************
  219.  * Same as WIDGET_CLASS's :set_callback method except that this understands
  220.  * how to get values from the XmCommandCallbackStruct.
  221.  * Specifying one or more of the following symbols in the callback bindings 
  222.  * list will bind that symbol's value in the lexical environment of the callback:
  223.  * CALLBACK_WIDGET
  224.  * CALLBACK_REASON
  225.  * CALLBACK_XEVENT
  226.  * CALLBACK_VALUE
  227.  * CALLBACK_LENGTH
  228.  ******************************************************************************/
  229. LVAL Xm_Command_Widget_Class_Method_SET_CALLBACK()
  230. {
  231.   extern LVAL Wcb_Meta_Method_Add_Callback(); /* w_callbacks.c */
  232.  
  233.   return (Wcb_Meta_Method_Add_Callback(XmCommandCallbackStruct_Callbackproc, TRUE));
  234. }
  235.  
  236.  
  237. /******************************************************************************
  238.  * (send <commandwidget> :get_child <symbol>)
  239.  * This method returns a WIDGETOBJ corresonding to <symbol>
  240.  * <symbol> can be :DIALOG_COMMAND_TEXT,
  241.  *                 :DIALOG_HISTORY_LIST, or
  242.  *                 :DIALOG_PROMPT_LABEL
  243.  *
  244.  * Widget XmCommandGetChild (widget, child)
  245.  * Widget   widget;
  246.  * unsigned char   child;
  247.  ******************************************************************************/
  248. LVAL Xm_Command_Widget_Class_Method_GET_CHILD()
  249. {
  250.   extern LVAL Wcls_WidgetID_To_WIDGETOBJ();
  251.   extern LVAL s_XmDIALOG_COMMAND_TEXT, s_XmDIALOG_HISTORY_LIST, s_XmDIALOG_PROMPT_LABEL;
  252.   LVAL self, lval_child;
  253.   Widget widget_id;
  254.   unsigned char child;
  255.  
  256.   widget_id = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&self);
  257.   lval_child = xlgasymbol();
  258.   xllastarg();
  259.   
  260.   if (lval_child == s_XmDIALOG_COMMAND_TEXT)
  261.     child = XmDIALOG_COMMAND_TEXT;
  262.   else if (lval_child == s_XmDIALOG_HISTORY_LIST)
  263.     child = XmDIALOG_HISTORY_LIST;
  264.   else if (lval_child == s_XmDIALOG_PROMPT_LABEL)
  265.     child = XmDIALOG_PROMPT_LABEL;
  266.   else 
  267.     xlerror("COMMAND_WIDGET_CLASS method :GET_CHILD -- unknown child type.", lval_child);
  268.  
  269.   return (Wcls_WidgetID_To_WIDGETOBJ(XmCommandGetChild(widget_id, child)));
  270. }
  271.  
  272.  
  273. /******************************************************************************
  274.  * (send <commandwidget> :set_value <value>)
  275.  * This sets the text in the widget's command area to the string or XmString
  276.  * <value>. If a normal string is given, it will be converted to an XmString
  277.  * and returned as the  method's result.
  278.  *
  279.  * void XmCommandSetValue (widget, value)
  280.  * Widget   widget;
  281.  * XmString value;
  282.  ******************************************************************************/
  283. LVAL Xm_Command_Widget_Class_Method_SET_VALUE()
  284. {
  285.   LVAL self, lval_value;
  286.   Widget widget_id;
  287.   XmString value;
  288.   extern XmString Get_String_or_XmString_Arg_Returning_XmString(); /* w_XmString.c */
  289.  
  290.   widget_id = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&self);
  291.   value = Get_String_or_XmString_Arg_Returning_XmString(&lval_value);
  292.   xllastarg();
  293.   
  294.   /* the lame part about all this is that the XmString value that we may
  295.      have converted above will just be cvted back to a string below. */
  296.   XmCommandSetValue(widget_id, value);
  297.   
  298.   return (lval_value);
  299. }
  300.  
  301.  
  302. /******************************************************************************
  303.  * (send <commandwidget> :append_value <value>)
  304.  * This appends the string or XmString <value> to the string in the command
  305.  * area widget. If a normal string is given, it will be converted to an
  306.  * XmString and returned as the method's result.
  307.  * 
  308.  * void XmCommandAppendValue (widget, value)
  309.  * Widget widget;
  310.  * XmString value;
  311.  ******************************************************************************/
  312. LVAL Xm_Command_Widget_Class_Method_APPEND_VALUE()
  313. {
  314.   LVAL self, lval_value;
  315.   Widget widget_id;
  316.   XmString value;
  317.   extern XmString Get_String_or_XmString_Arg_Returning_XmString(); /* w_XmString.c */
  318.  
  319.   widget_id = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&self);
  320.   value = Get_String_or_XmString_Arg_Returning_XmString(&lval_value);
  321.   xllastarg();
  322.   
  323.   /* the lame part about all this is that the XmString value that we may
  324.      have converted above will just be cvted back to a string below */
  325.   XmCommandAppendValue(widget_id, value);
  326.   
  327.   return (lval_value);
  328. }
  329.  
  330.  
  331. /******************************************************************************
  332.  * (send <commandwidget> :error <error>)
  333.  * This temporarily displays the string or XmString <error> in the history
  334.  * area of the command widget, the display is cleared upon entry of the
  335.  * next command. If a normal string is given, it will be converted to an
  336.  * XmString and returned as the method's result.
  337.  *
  338.  * void XmCommandError (widget, error)
  339.  * Widget widget;
  340.  * XmString error;
  341.  ******************************************************************************/
  342. LVAL Xm_Command_Widget_Class_Method_ERROR()
  343. {
  344.   LVAL self, lval_value;
  345.   Widget widget_id;
  346.   XmString value;
  347.   extern XmString Get_String_or_XmString_Arg_Returning_XmString(); /* w_XmString.c */
  348.  
  349.   widget_id = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&self);
  350.   value = Get_String_or_XmString_Arg_Returning_XmString(&lval_value);
  351.   xllastarg();
  352.   
  353.   /* the lame part about all this is that the XmString value that we may
  354.      have converted above will just be cvted back to a string below */
  355.   XmCommandError(widget_id, value);
  356.   
  357.   return (lval_value);
  358. }
  359.  
  360.  
  361. /******************************************************************************
  362.  * (send <commandwidget> :GET_HISTORY_ITEMS)
  363.  *     ==> returns an array of XmStrings.
  364.  *
  365.  * This retrieves the XmCommand widget resources XmNhistoryItems and
  366.  * XmNhistoryItemCount from <commandwidget> and returns an array of XmStrings
  367.  * representing the history items.
  368.  *******************************************************************************/
  369. LVAL Xm_Command_Widget_Class_Method_GET_HISTORY_ITEMS()
  370. {
  371.   LVAL self;
  372.   Widget widget_id;
  373.   XmStringTable xmstrtab;
  374.   int        xmstrtab_size;
  375.  
  376.   widget_id = Wcls_Get_WIDGETOBJ_Argument_Returning_Validated_WidgetID(&self);
  377.   xllastarg();
  378.  
  379.   ARGLIST_RESET();
  380.   ARGLIST_ADD(XmNhistoryItems, &xmstrtab);
  381.   ARGLIST_ADD(XmNhistoryItemCount, &xmstrtab_size);
  382.   XtGetValues(widget_id, ARGLIST());
  383.  
  384.   return (Wxms_XmStringTable_To_Lisp_Vector(xmstrtab, xmstrtab_size));
  385. }
  386.  
  387.  
  388. /******************************************************************************
  389.  *
  390.  ******************************************************************************/
  391. Wc_Command_Init()
  392. {
  393.   LVAL o_XM_COMMAND_WIDGET_CLASS;
  394.   extern LVAL Wcls_Create_Subclass_Of_WIDGET_CLASS(); /* w_classes.c */
  395.   extern      xladdmsg();    /* from xlobj.c */
  396.  
  397.   o_XM_COMMAND_WIDGET_CLASS =
  398.     Wcls_Create_Subclass_Of_WIDGET_CLASS("XM_COMMAND_WIDGET_CLASS",
  399.                      xmCommandWidgetClass);
  400.  
  401.   /* a special :isnew method on this class allows for the creation of this
  402.    * widget with Command.c:XmCreateCommand(), rather than using default
  403.    * :ISNEW (which does XtCreateWidget()). The only special thing done by
  404.    * XmCreateCommand() is that it prepends the following arg to the arglist:
  405.    * XmNdialogType == XmDIALOG_COMMAND.
  406.    */
  407.   xladdmsg(o_XM_COMMAND_WIDGET_CLASS, ":ISNEW", 
  408.        FTAB_Xm_Command_Widget_Class_Method_ISNEW);
  409.  
  410.   xladdmsg(o_XM_COMMAND_WIDGET_CLASS, ":ADD_CALLBACK",
  411.            FTAB_Xm_Command_Widget_Class_Method_ADD_CALLBACK);
  412.  
  413.   xladdmsg(o_XM_COMMAND_WIDGET_CLASS, ":SET_CALLBACK",
  414.            FTAB_Xm_Command_Widget_Class_Method_SET_CALLBACK);
  415.  
  416.   xladdmsg(o_XM_COMMAND_WIDGET_CLASS, ":GET_CHILD",
  417.            FTAB_Xm_Command_Widget_Class_Method_GET_CHILD);
  418.  
  419.   xladdmsg(o_XM_COMMAND_WIDGET_CLASS, ":ERROR",
  420.        FTAB_Xm_Command_Widget_Class_Method_ERROR);
  421.  
  422.   xladdmsg(o_XM_COMMAND_WIDGET_CLASS, ":SET_VALUE",
  423.        FTAB_Xm_Command_Widget_Class_Method_SET_VALUE);
  424.  
  425.   xladdmsg(o_XM_COMMAND_WIDGET_CLASS, ":APPEND_VALUE",
  426.        FTAB_Xm_Command_Widget_Class_Method_APPEND_VALUE);
  427.  
  428.   xladdmsg(o_XM_COMMAND_WIDGET_CLASS, ":GET_HISTORY_ITEMS",
  429.        FTAB_Xm_Command_Widget_Class_Method_GET_HISTORY_ITEMS);
  430. }
  431.